COMMENT ⊗   VALID 00020 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	Definitions.  The file DEFS must be assembled with this file.
C00005 00003		storage allocations
C00010 00004	DOER	NEXT	NEXT1
C00014 00005	LOOKBG
C00018 00006	COLECT	ENDIT
C00021 00007	WORD
C00025 00008	SORT0
C00027 00009	WRITE OUT NEW STORY IN TXT FILE   --	CATEG	CATEG0
C00032 00010	KEYW	DONE -- HERE WE LINK ALL THE STORY WORDS INTO THE DICTIONARY LISTS
C00038 00011	CHGNAM	INTRPT
C00040 00012	UUCODE	NXTDG	DOEXIT
C00042 00013	GETCH
C00044 00014	PUTCH	PUTSTR	PUT2DG
C00046 00015	MAKTIM
C00048 00016	TFLFIL	BADTFL
C00050 00017	CHKUFD	UFDENT	OPNUFD
C00053 00018	READAT	WRTDAT	WAIT
C00058 00019	NETWRK
C00062 00020	DATA
C00063 ENDMK
C⊗;
;Definitions.  The file DEFS must be assembled with this file.
IFNDEF DEBUG <DEBUG←0>
	TITLE	DOER -- categorizer of AP stories
NOVIZ←←1 ;NON-ZERO MEANS STRIP VISUAL PAPER TAPE NUMBER FROM FRONT OF EACH STORY

F←0
A←1
B←2
C←3	;current character
D←4
E←5	;counter and temporary AC

L←6	;length of output text line.  Also, number of different keywords.
M←7
N←10

Q←11	;byte pointer into output story buffer
R←12	;temporary byte pointer

W←13	;W:Z are used as LOOKUP and ENTER block
X←14
Y←15
Z←16

P←17	;pdl pointer

;I/O channels

TO ←←0	;text output to .TXT file
TI ←←1	;text input from .TFL file
UFD←←2	;input from UFD
DAT←←3	;input from, and output to, .DAT file
DT ←←4	;deletion of old .DAT files
TX ←←5	;deletion of old .TXT files
D0 ←←6	;input/output of DATE00.DAT file
;	storage allocations

IFN DEBUG <

LSYM←←2000
SYM:	BLOCK LSYM

>;END IFN DEBUG

DSK17:	217
	SIXBIT	/DSK/
	0

DSK417:	617		;FOR LONG BLOCK LOOKUPS
	SIXBIT	/DSK/
	0

DATE00:	BLOCK	2	;FOR HOLDING DATE00.DAT FILE
DATECM:	IOWD	2,DATE00;DUMP MODE CMD FOR READING DATE00.DAT FILE
	0

NTOBUF←←8		;number of records in story buffer--must hold whole story
LBUF←←200*NTOBUF
	BLOCK	200	;buffer for holding first part of record where story starts
BUF:	BLOCK	LBUF	;story buffer for collecting entire story
BUFEND←.-20		;address used for checking for story buffer overflow
TOCMD:	IOWD LBUF,BUF	;dump mode command for writing out new story in .TXT file
	0
DATCMD:	IOWD 1,DATA	;dump mode command for reading/writing .DAT goes here
	0

MAXIGN←←=30	;number of chars we are willing to ignore in from of story
TMPBUF:	BLOCK	2*MAXIGN/5

LORIGS←←5
ORIGS:	BLOCK	LORIGS	;list of sequence numbers referenced by current story
NORIGS:	-1		;number of entries in ORIGS, minus 1

LTEXT←←=600
TEXT:	BLOCK	LTEXT	;space for collecting and storing whole keywords together

LSORT←←=400
SORT:	BLOCK	LSORT	;list of sorted keywords: <link>,,<ptr into TEXT>

TFL:	0		;negative of number of .TFL filenames in table
LTFLST←←20
	BLOCK	LTFLST	;sorted list of .TFL filenames
TFLST:			;name of this block must follow the block
TFLNAM:	0		;name of current .TFL file open (zero if none)

NUBUFS←←2
UFDBUF:	BLOCK 203*NUBUFS;buffer space for reading UFD
UBUF:	BLOCK	3	;buffer header for reading UFD

NTIBUF←←2
TIBUF:	BLOCK 203*NTIBUF;buffer space for reading in .TFL files
IBUF:	BLOCK	3	;buffer header for reading .TFL files

LPDL←←30
PDL:	BLOCK	LPDL	;pushdown list

ERRBK:	SIXBIT	/DSK/	;block used to start up error-handling program
	ERRPRG		;program name goes here
	'DMP',,0
	1		;NORMAL CORE SIZE, RPG STARTUP (SA+1)
	APPPN
	APPPN

CHKBK:	SIXBIT	/DSK/	;block used to start up CHK program
	SIXBIT	/CHK/	;program name goes here
	'DMP',,14	;START UP AS PHANTOM JOB
	0,,-1		;NORMAL CORE SIZE, SPECIAL STARTUP (SA-1)
	APPPN
	APPPN

MONTH:	FOR MON IN (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec)
<	ASCII	\MON \
>

SEQNBR:	0		;sequence number of current story
ORIGIN:	0		;pointer (in left half) to original of follow-up, if any
NEWSEQ:	0		;sequence number of next story (when already seen)
EOF:	0		;flag indicating whether there is an input file open
EOFDSP:	0		;address of routine to dispatch to on EOF from .TFL file
EOSDSP:	0		;address of routine to dispatch to on End Of Story
DATIN:	0		;flag telling if .DAT file has been read in
IGNORE:	0		;number of characters we will ignore looking for story
HNGTIM:	0		;number of times we have tried to do an ENTER and failed
HNGADR:	0		;return address of WAIT routine

APMIDNIGHT←←=21*=3600	;SU-AI time in seconds when AP goes to next day
ABSMINDATE←←7113	;7 JAN 74 in DAYCNT format
ABSMAXDATE←←7665	;4 JAN 75 in DAYCNT format
TODAY:	0		;today's date in DAYCNT format--used as file name
MINDATE:ABSMINDATE	;earliest reasonable date for TFL file, in DAYCNT format

APNAME:	SIXBIT /[DOER]/
;DOER	NEXT	NEXT1

DOER:	RESET
	MOVE	P,[IOWD LPDL,PDL]

	MOVEI	A,INTRPT	;get address of interrupt level module
	MOVEM	A,JOBAPR↑	;store it
	MOVSI	A,INTPTI!INTPAR	;enable interrupts on parity errors
	INTENB	A,		;	and pty input
	MOVSI	A,INTPTI
	INTGEN	A,		;generate a pty input int to set the job name
	MOVE	A,NBRFLR#	;get code indicating number of other DOERs
	JRST	.+2(A)
	EXIT			;ONE OTHER DOER ALREADY EXISTED
	UFATAL	102		;;;TWO OR MORE OTHER DOERS ALREADY EXISTED

	SETZM	TFL		;no .TFL filenames sorted yet
	SETZM	TFLNAM		;no .TFL file open yet
	SETZM	DATIN		;no .DAT file in core yet
	HRROS	JOBDDT↑		;make sure SAVE gets everybody

	INIT	TI,200		;prepare to read .TFL file in
	SIXBIT	/DSK/
	IBUF
	UFATAL	104		;;;CANT INIT DSK
	MOVEI	W,TIBUF
	MOVEM	W,JOBFF↑
	INBUF	TI,NTIBUF	;set up buffers in compiled in area

NEXT:	PUSHJ	P,TFLFIL	;open oldest .TFL file
	JRST  [	PUSHJ P,NETWRK	;no .TFL files, do anything needed with DC at CCA
		PUSHJ P,TFLFIL	;look again for .TFL files
		JRST DOEXIT	;still none--do any bookkeeping and exit
		JRST NEXT1]	;got one--process it
NEXT1:	MOVEI	W,NEXT
	MOVEM	W,EOFDSP	;set up dispatch address for EOF
	MOVEI	W,.+2
	MOVEM	W,EOSDSP	;set up dispatch address for END OF STORY
	SETZB	C,L		;clear current character, no chars on current line
	MOVEI	W,MAXIGN	;set up counter for maximum number of chars we
	MOVEM	W,IGNORE	;  will examine in searching for story beginning
	MOVE	Q,[POINT 7,TMPBUF] ;set up byte pointer for saving story read in
;LOOKBG

LOOKBG:	PUSHJ	P,GETCH		;look for beginning of a story
LOOKB3:	CAIN	C,"a"		;stories begin with "a109" followed by LF
	JRST	LOOKB2		;maybe we got one
	CAIE	C,LF		;(don't count LFs in limit of chars before beginning)
	SOSL	IGNORE		;have we looked far enough for a beginning
	JRST	LOOKBG		;no--look some more

	SETZ	C,		;yes--insert special beginning
	IDPB	C,Q		;mark end of text seen so far
	MOVE	Q,[POINT 7,BUF]	;set up byte pointer into story buffer
	MOVEI	R,=999
	MOVEM	R,SEQNBR	;give this story a special sequence number
	MOVEI	R,[ASCIZ /a999/]
	PUSHJ	P,PUTSTR	;put special sequence number into story
	PUSHJ	P,MAKTIM	;put time of categorization into story
	MOVEI	R,[ASCIZ /(Beginning missing.)
.../]
	PUSHJ	P,PUTSTR	;and add special message to beginning of story
	MOVEI	R,TMPBUF
	PUSHJ	P,PUTSTR	;copy text seen so far into story buffer
	JRST	COLECT		;and go collect rest of story

LOOKB2:	MOVEI	E,3		;look for 3 digits of seq nbr
	SETZ	D,		;calculate seq nbr in D
LOOKB1:	PUSHJ	P,GETCH
	CAIL	C,"0"
	CAILE	C,"9"		;is next char a digit?
	JRST	LOOKB3		;no--start over looking for beginning
	IMULI	D,=10
	ADDI	D,-"0"(C)	;add current digit into seq nbr value so far
	SOJG	E,LOOKB1	;found enough digits yet?
	PUSHJ	P,GETCH		;yes
	CAIE	C,LF		;three digits must be followed by LF
	JRST	LOOKB3		;must not be real beginning

	MOVEM	D,SEQNBR	;GOT BEGINNING OF STORY--SAVE SEQUENCE NUMBER
	ADD	Q,[070000,,0]	;BACK UP Q TO THE CR AFTER STORY NUMBER
	TLNE	Q,400000	;DID BYTE POINTER POSITION FIELD OVERFLOW?
	SUB	Q,[430000,,1]	;YES, ADJUST BP TO LAST BYTE IN PREVIOUS WORD
	DPB	E,Q		;mark end of seq nbr, and erase the CR
	MOVE	R,Q
	SUBI	R,1		;back up byte pointer R over seq nbr
	MOVE	Q,[POINT 7,BUF]	;set up byte pointer into story buffer
	PUSHJ	P,PUTST1	;copy ASCIZ string from TMPBUF into story buffer
COLEC0:	PUSHJ	P,MAKTIM	;put time of categorization into story
	INSKIP	1
	JRST	CONTIN
	OUTSTR	[ASCIZ/Manual stop.  CONTINUE will work./]
	CLRBFI
	EXIT	1,

;here is where we want to skip over the paper tape visual number (czzcxwwxyzzy)
CONTIN:
IFDEF NOVIZ<
IFN NOVIZ <
	PUSH	P,Q
	MOVEI	E,=22		;IF NEXT LINE LONGER THAT THIS, IS NOT VISUAL NUMBER
	PUSHJ	P,GETCH		;LOOK FOR A LF AT END OF VISUAL NUMBER
	CAIE	C,LF
	SOJG	E,.-2
	POP	P,D
	JUMPLE	E,.+2
	MOVE	Q,D		;HAVE FOUND LF IN TIME, DISCARD VISUAL NUMBER
>;END IFN NOVIZ
>;END IFDEF NOVIZ
;COLECT	ENDIT

COLECT:	MOVEI	E,ENDIT
	MOVEM	E,EOSDSP	;set up dispatch address for end of story found
	MOVEI	E,ENDIT1
	MOVEM	E,EOFDSP	;set up dispatch address for EOF
	SETZM	TMPBUF		;no new beginning seen yet.

COLEC3:	PUSHJ	P,GETCH		;look for beginning: "a109" LF
COLEC1:	CAIE	C,"a"
	JRST	COLEC3
	MOVEI	E,3
	SETZ	D,
COLEC2:	PUSHJ	P,GETCH
	CAIL	C,"0"
	CAILE	C,"9"
	JRST	COLEC1
	IMULI	D,=10
	ADDI	D,-"0"(C)
	SOJG	E,COLEC2
	PUSHJ	P,GETCH
	CAIE	C,LF
	JRST	COLEC1
	MOVEM	D,NEWSEQ
	ADD	Q,[067777,,-1]	;back up byte pointer over new story beginning seen
	PUSH	P,Q
	MOVEI	E,4
	MOVE	R,[POINT 7,TMPBUF]
	ILDB	C,Q
	IDPB	C,R		;save new story beginning in TMPBUF
	SOJG	E,.-2
	POP	P,Q
	JRST	ENDIT1

ENDIT:	SETZM	IBUF+2		;force next GETCH to get new record
	LDB	C,Q		;GET LAST CHAR IN STORY
	CAIE	C,LF		;SHOULD HAVE ENDED WITH LF
	JRST	ENDIT1		;DIDN'T END RIGHT
	MOVE	R,Q		;COPY BYTE PTR
	SUBI	R,2		;back up byte ptr 8 bytes
	IBP	R
	IBP	R
	ILDB	C,R		;see if story ended with CR,LF,SP,CR,LF,SP,CR,LF
	CAIE	C,CR
	JRST	ENDIT2		;NOPE
	ILDB	C,R
	CAIE	C,LF
	JRST	ENDIT2		;NOPE
	MOVE	Q,R		;set up byte ptr to end of real part of story
	JRST	ENDIT3		;NORMAL END OF STORY
ENDIT2:	LDB	C,Q		;get last char in story
ENDIT1:	CAIN	C,CR		;are we in the middle of a CRLF?
	PUSHJ	P,PUTLF		;yes--put in the LF
	MOVEI	R,[ASCIZ /...
(End missing.)
/]
	PUSHJ	P,PUTSTR	;put special message at end of story
ENDIT3:	SETZ	C,
	IDPB	C,Q		;put null byte at end of story
	TLNE	Q,760000	;and fill out whole word with nulls
	JRST	.-2
;WORD

	SETZM	TEXT
	MOVE	E,[TEXT,,TEXT+1]
	BLT	E,TEXT+LTEXT-1	;clear TEXT space
	SETOM	NORIGS		;no references to original stories yet
	SETZB	L,SORT		;clear keyword list header, length of list
	MOVE	Q,[POINT 7,BUF+4,20] ;set up byte pointer to beginning of story
				;don't categorize by seq nbr, time and date
	MOVE	R,[POINT 5,TEXT-1,34] ;set up byte pointer for collecting individual words

WORD:	ILDB	C,Q
WORD1:	JUMPE	C,CATEG		;zero means end of story--go do categorizing
	CAIGE	C,"A"		;look for beginning of a word--do we have a letter?
	JRST	WORD		;no
	CAIGE	L,LSORT-1	;too many keywords yet?
	CAML	R,[010500,,TEXT+LTEXT-=10] ;or run out of TEXT space yet?
	JRST	CATEG0		;yes to one of these--ignore remaining words
	ADDI	L,1		;count a new keyword
	HRRZM	R,SORT(L)	;store pointer to TEXT of this keyword
WORD3:	IDPB	C,R
	ILDB	C,Q		;get next char
	CAIL	C,"A"		;is it a letter?
	JRST	WORD3		;yes--here we go loop de loop
WORD2:	LDB	E,R		;no--see if perhaps have a story reference
	CAIE	E,"A"-100	;was last char an upper or lower case "A"?
	JRST	SORT0		;no--go sort this keyword into list
WORD5:	SETZ	D,		;collect sequence number in D
	MOVEI	E,3		;look for 3 digits
WORD4:	CAIL	C,"0"
	CAILE	C,"9"		;got a digit?
	JRST	WORD6A		;no--see if exactly 3 digits found
	IMULI	D,=10
	ADDI	D,-"0"(C)	;add digit into value so far
	ILDB	C,Q		;next char
	SOJGE	E,WORD4		;found enough digits yet?
WORD6A:	JUMPN	E,SORT0		;if E≠0 then wrong nbr of digits--sort word into list
WORD6:	CAMGE	D,SEQNBR	;see if this is a forward reference
	JRST	WORD7		;nope
	MOVE	E,SEQNBR
	CAIGE	D,20(E)		;if forward by more than 20, probably backward
	JRST	WORD7A		;forward reference, forget it
WORD7:	AOS	E,NORIGS	;found another story reference
	CAIL	E,LORIGS	;found too many already?
	SOSA	NORIGS		;yes--forget this one
	MOVEM	D,ORIGS(E)	;no--remember this one
WORD7A:	CAIE	C,"-"		;do we have several consecutive references?
	JRST	SORT0		;no--now insert keyword into sorted list
	ILDB	C,Q		;yes
	JRST	WORD5		;go back and get the next one
;SORT0

SORT0:	MOVEI	E,1
	ORM	E,(R)		;mark end of keyword in TEXT
	HRLI	R,010500	;advance byte pointer to end of word
	TDZA	D,D		;look at front of keyword list
SORT1:	MOVE	D,E
	HLRZ	E,SORT(D)	;get next word in list
	JUMPE	E,SORT4		;insert new word at end of list
	HRRZ	A,SORT(L)	;get ptr to text of new word
	HRRZ	B,SORT(E)	;get ptr to text of old word
SORT2:	MOVE	M,1(A)		;get a word of text of new word
	CAMLE	M,1(B)		;and compare against corresponding part of old word
	JRST	SORT1		;move on down keyword list
	CAME	M,1(B)
	JRST	SORT4		;insert right here in list
	TRNN	M,1		;keywords equal so far--at end of keyword?
	AOJA	A,[AOJA B,SORT2];no--get next part of each keyword
	MOVEI	E,1		;yes--keywords are the same
	JRST	SORT3A		;undo entries for new keyword
SORT3:	TDNE	E,(R)		;found end of previous keyword in TEXT?
	SOJA	L,WORD1		;yes--delete entry from sorted list
SORT3A:	SETZM	(R)		;no--clear TEXT for this word
	SOJA	R,SORT3		;back up a word in TEXT
SORT4:	HRLM	L,SORT(D)	;link new keyword into sorted list
	HRLM	E,SORT(L)
	JRST	WORD1
;WRITE OUT NEW STORY IN TXT FILE   --	CATEG	CATEG0

CATEG0:	ILDB	C,Q		;ADVANCE BYTE POINTER TO END OF STORY
	JUMPN	C,.-1
CATEG:	PUSHJ	P,READAT	;READ IN .DAT FILE (IF HAVEN'T ALREADY)

	OPEN	TO,DSK17
	UFATAL	106		;;;CANT OPEN DSK
	MOVE	W,TODAY
	MOVSI	X,'TXT'
	SETZ	Z,
	LOOKUP	TO,W
	UFATAL	110		;;;LOOKUP FAILED ON DAY'S .TXT FILE
	SETZB	Y,Z
	ENTER	TO,W		;open .TXT file in RA mode
	PUSHJ	P,WAIT		;can't right now--wait a bit and try again
	HRRZ	W,DATA+2	;PICK UP ADDRESS WITHIN TXT FILE WHERE STORY WILL GO
	SETZ	X,
	LSHC	W,-7		;RECORD NUMBER-1 INTO W, DISPLACEMENT INTO X
	JUMPE	X,CATEG1	;DOES STORY GO INTO MIDDLE OF A RECORD?
	ROT	X,7		;YES, READ FIRST PART OF RECORD
	MOVNI	X,(X)		;NEGATIVE AMOUNT OF OLD STUFF TO BE READ IN
	HRLI	X,BUF-1(X)	;ADDRESS FOR DUMP MODE INPUT COMMAND
	MOVSM	X,TOCMD
	USETI	TO,1(W)
	IN	TO,TOCMD	;READ IN A LITTLE OLD STUFF
	JRST	CATEG2
	UFATAL	112		;;;IN UUO FAILED TO READ IN END OF LAST STORY
CATEG1:	MOVEI	X,BUF-1		;NO OLD STUFF READ IN--SET UP OUTPUT DMP MODE ADDR
	MOVEM	X,TOCMD
CATEG2:	MOVEI	Q,1-BUF(Q)	;LENGTH OF STORY
	PUSH	P,DATA+2	;SAVE PTR TO PLACE FOR STORY
	ADDB	Q,DATA+2	;UPDATE POINTER TO FIRST FREE WORD IN TXT
	USETO	TO,1(W)
	LSH	W,7
	SUBI	W,(Q)
	HRLM	W,TOCMD
	OUT	TO,TOCMD	;write out new story
	JRST	.+2
	UFATAL	114		;;;OUT UUO FAILED TO WRITE OUT NEW STORY
	RELEAS	TO,		;done with .TXT file for now

;LINK NEW STORY TO EARLIER STORY IF NECESSARY
	HLRZ	E,DATA+2	;ptr to first free word in DAT
	MOVSM	E,ORIGIN
	SKIPGE	C,NORIGS
	JRST	CATEG5		;NO REFERENCES TO EARLIER STORY
	MOVNI	C,1(C)
	MOVSI	C,(C)		;AOBJN PTR TO STORY REFS
CATEG3:	MOVE	B,ORIGS(C)	;GET NEXT REF
	HLRZ	L,DATA		;PTR TO LAST STORY ENTRY
	JUMPE	L,CATEG5
CATEG7:	HRRZ	M,DATA+2(L)	;GET SEQ NBR OF PREV STORY
	CAIE	B,(M)		;SAME AS REF?
	JRST	CATEG4		;NO
	HLLZ	N,DATA+3(L)	;YES, GET ORIGINAL OF STORY TO LINK TO
	HLLZM	N,ORIGIN	;REMEMBER WHICH STORY TO USE IN CATEGORIZING
CATEG6:	HRRZ	N,DATA+3(L)	;ANY FOLLOW-UPS ALREADY?
	EXCH	L,N
	JUMPN	L,CATEG6	;IF SO, TRACE DOWN LIST TO LAST FOLLOW-UP
	HRRM	E,DATA+3(N)	;MAKE LAST FOLLOW-UP POINT TO NEW STORY
	JRST	CATEG5
CATEG4:	HLRZ	L,DATA(L)	;GET PTR TO NEXT PREV STORY
	JUMPN	L,CATEG7	;ANY MORE STORIES?
	AOBJN	C,CATEG3	;NO, ANY MORE STORY REFERENCES?
				;NO
;MAKE NEW ENTRY IN STORY LIST
CATEG5:	HLRZ	A,DATA		;PTR TO LAST STORY ENTRY
	HRLZM	A,DATA(E)	;MAKE NEW STORY ENTRY POINT TO PREV ONE
	HRRM	E,DATA(A)	;MAKE PREV STORY ENTRY POINT TO NEW ONE
	HRLM	E,DATA		;NEW VALUE FOR POINTER TO LAST STORY ENTRY
	POP	P,A		;RETRIEVE SAVED PTR TO NEW STORY IN TXT
	HLL	A,TOCMD		;GET DUMP MODE COMMAND NEEDED FOR STORY
	MOVEM	A,DATA+1(E)	; AND PLACE INTO STORY ENTRY
	HRRZ	A,SEQNBR	;GET NEW STORY'S SEQ NBR
	MOVEM	A,DATA+2(E)	; AND PLACE INTO STORY ENTRY
	MOVE	A,ORIGIN
	MOVEM	A,DATA+3(E)	;SET UP PTR TO ORIGINAL STORY
	ADDI	E,4		;NOTE WE USED UP FOUR MORE WORDS OF DAT
;KEYW	DONE -- HERE WE LINK ALL THE STORY WORDS INTO THE DICTIONARY LISTS

	HRRZ	D,DATA+1	;PTR TO FIRST DICT ENTRY
	HLRZ	C,SORT		;PTR TO FIRST WORD IN STORY
	JUMPE	C,DONE		;IF NO WORDS, TAKE IT EASY
KEYW:	MOVEI	B,DATA+1(D)	;SET UP ADDRESS OF TEXT OF DICT WORD
	SKIPGE	DATA(D)		; ADJUST THAT ADDRESS IF DICT ENTRY HAS EXTRA FIELDS
	ADDI	B,2
	HRRZ	A,SORT(C)	;ADDRESS OF TEXT OF WORD IN STORY
KEYW1:	MOVE	M,1(A)		;PICK UP 7 CHARS FROM STORY WORD
	CAME	M,(B)		;SAME AS THOSE OF DICT WORD?
	JRST	KEYW2		;NO
	TRNN	M,1		;YES, ARE WE TO THE END OF THE WORD?
	AOJA	A,[AOJA B,KEYW1];NO, ADVANCE BOTH POINTERS TO TEXT AND GO ON
	SKIPGE	A,1(B)		;YES. IS THIS DICT ENTRY FOR A COMMON ENGLISH WORD?
	JRST	KEYW9		;YES, IGNORE THIS WORD
	JUMPN	A,KEYW3		;NO, IS THERE AN OCCURRENCE ENTRY FOR THIS WORD?
	HLLZ	A,ORIGIN	;NO, THIS IS EASY.  PICK UP POINTER TO STORY
	MOVEM	A,1(B)		; AND DEPOSIT IN "COMPILED-IN" SPACE IN DICT ENTRY
	JRST	KEYW9

KEYW3:	HLLZ	M,ORIGIN	;PICK UP POINTER TO STORY CATEGORIZATION GOES WITH
	MOVEM	M,DATA(E)	;AND DEPOSIT IT IN NEW WORD-OCCURRENCE ENTRY
	MOVEI	A,1-DATA(B)	;SET UP POINTER TO FIRST W.O.
	HLLZ	N,DATA(A)	;PICK UP STORY INDEX OF FIRST STORY FOR THIS WORD
	CAMGE	N,M		;IS STORY BEING CATEGORIZED BEFORE FIRST STORY GIVEN?
	JRST	KEYW5A		;NO
	CAMG	N,M		;YES
	JRST	KEYW9		;THAT STORY ALREADY CATEGORIZED BY THIS WORD
	MOVE	N,DATA(A)	;PICK UP FIRST W.O. ENTRY
	MOVEM	N,DATA(E)	;AND PLACE IT IN NEW SLOT
	HRR	M,E		;MAKE NEW W.O. POINT TO OLD FIRST ONE
	MOVEM	M,DATA(A)	;PUT NEW W.O. IN "COMPILED-IN" SLOT
	AOJA	E,KEYW9

KEYW5:	HLLZ	N,DATA(A)
	CAML	N,M
	JRST	KEYW4
KEYW5A:	HRRZ	B,DATA(A)	;WALK DOWN LIST OF OCCURRENCES OF THIS DICT WORD
	JUMPE	B,KEYW6		;ARE WE AT THE END YET?
	HLLZ	N,DATA(B)
	CAML	N,M
	JRST	KEYW4A		;INSERT W.O. HERE IN LIST
	HRRZ	A,DATA(B)	;NO, PICK UP NEXT POINTER
	JUMPN	A,KEYW5		;AT END?
	MOVE	A,B		;YES
KEYW6:	HRRM	E,DATA(A)	;MAKE LAST WORD OCCURRENCE POINT TO NEW ONE
	AOJA	E,KEYW9		;NOTE WE USED UP ANOTHER WORD IN DAT FOR W.O.

KEYW4:	EXCH	A,B
KEYW4A:	CAMN	N,M
	JRST	KEYW9		;STORY ALREADY CATEGORIZED BY THIS KEYWORD
	HRRM	B,DATA(E)	;MAKE THIS NEW W.O. POINT TO NEXT ONE
	JRST	KEYW6

KEYW8:	HRRZ	D,DATA(D)	;ADVANCE TO NEXT DICT ENTRY
	JRST	KEYW

KEYW2:	CAML	M,(B)		;HAVE WE PASSED SPOT FOR THIS STORY WORD IN DICT?
	JRST	KEYW8		;NO, GET NEXT DICT ENTRY
	HLL	D,DATA(D)	;YES. PICK UP POINTER TO PREV DICT ENTRY
	MOVEM	D,DATA(E)	;PUT FORWARD/BACKWARD DICT POINTERS INTO NEW ENTRY
	HRLM	E,DATA(D)	;MAKE NEXT ENTRY POINT BACK TO NEW ONE
	MOVS	B,D		;GET POINTER TO PREV ENTRY
	HRRM	E,DATA(B)	;MAKE PREV ENTRY POINT FORWARD TO NEW ONE
	TRNE	M,1		;HAVE WE GOTTEN TO THE LAST CHARS IN STORY WORD?
	JRST	KEYW2A		;YES
	ADDI	A,1		;NO, EXAMINE NEXT 7 CHARS
	MOVEI	M,1		; UNTIL WE SEE END OF WORD (LOW ORDER BIT ON)
	TDNN	M,1(A)
	AOJA	A,.-1
KEYW2A:	HRRZ	B,SORT(C)	;PICK UP ADDRESS OF TEXT OF STORY WORD
	SUBI	A,-1(B)		;SUBTRACT FROM ADDRESS OF LAST PART TO GET LENGTH
	MOVSI	B,1(B)		;PUT BLT ORIGIN ADDRESS IN LEFT HALF OF B
	HRRI	B,DATA+1(E)	;WILL BLT TEXT INTO NEW DICT ENTRY
	ADDI	E,2(A)		;UPDATE POINTER TO FIRST FREE WORD IN DAT
	BLT	B,DATA-2(E)	;MOVE TEXT OF WORD
	HLLZ	A,ORIGIN	;PICK UP POINTER TO STORY BEING CATEGORIZED
	MOVEM	A,DATA-1(E)	;AND PUT INTO FIRST W.O. ENTRY FOR NEW DICT WORD
KEYW9:	HLRZ	C,SORT(C)	;ADVANCE TO NEXT WORD IN STORY
	JUMPN	C,KEYW		;ANY MORE WORDS IN STORY?
DONE:	HRLM	E,DATA+2	;STORE NEW VALUE FOR FIRST FREE WORD IN DAT
	PUSHJ	P,WRTDAT	;WRITE OUT DAT FILE
	SKIPE	A,TMPBUF
	JRST	DONE1
	SKIPE	EOF
	JRST	NEXT		;GET NEW INPUT FILE
	JRST	NEXT1		;CONTINUE READING OLD FILE

DONE1:	MOVEM	A,BUF
	MOVE	Q,[POINT 7,BUF,27]
	SETZB	C,L		;clear current char, number of chars on current line
	MOVE	A,NEWSEQ
	MOVEM	A,SEQNBR
	JRST	COLEC0
;CHGNAM	INTRPT

;interrupt level routine to set the job name
CHGNAM:	SETZ	A,			;zero out own job name
	SETNAM	A,
	SETOM	NBRFLR#			;initialize indicator to one other DOER
	MOVE	A,APNAME		;get DOER's name
	NAMEIN	A,
	JRST	.+2			;zero or multiple DOERs exist
	DISMIS				;one other DOER exists
	SETZM	NBRFLR			;set indicator to multiple DOERs
	CAIE	A,1			;check error code of NAMEIN
	DISMIS				;two or more other DOERs exist
	AOS	NBRFLR			;set indicator to no other DOERs
	MOVE	A,APNAME		;change job name
	SETNAM	A,
	MOVEI	A,INTPTI
	INTACM	A,			;disable interrupt used for name change
	DISMIS

;interrupt level module
INTRPT:	MOVS	A,JOBCNI↑	;get bit causing interrupt
	CAIN	A,INTPTI	;is this interrupt to set DOER's job name?
	JRST	CHGNAM		;yes.  do it
	CAIE	A,INTPAR
	DISMIS			;IGNORE STRANGE INTERRUPT
	UWAIT			;PARITY ERROR.  GIVE UP AND GO HOME
	JRST	2,@[.+1]	;get out of user-iot
	DEBREAK
	EXIT			;PARITY ERROR IN DOER
;UUCODE	NXTDG	DOEXIT

UUCODE:	0
	PUSH	P,A
	PUSH	P,B
	SETO	A,
	GETLIN	A
	AOJE	A,DET
	OUTSTR	[ASCIZ /
DOER error #/]
	HRRZ	A,40		;get error number
	PUSHJ	P,NXTDG		;TYPE OUT ERROR NUMBER
	POP	P,B
	POP	P,A
	EXIT	1,
	HALT	.
	JRST	@UUCODE

DET:	HLRZ	A,40		;GET UUO LH
	ANDI	A,777000	;MASK OUT ALL BUT OPCODE
	SETZ	B,
	CAIN	A,(<UWARN>)	;JUST A WARNING?
	MOVEI	B,14		;YES, START UP ERROR PROGRAM ON ANOTHER JOB
	HRRM	B,ERRBK+2	;STORE MODE BITS FOR SWAP
	MOVE	1,APNAME	;PASS JOB NAME IN AC 1
	MOVE	2,40		; AND ERROR UUO IN AC 2
	MOVEI	16,ERRBK
	SWAP	16,
	POP	P,B
	POP	P,A
	JRST	@UUCODE		;CONTINUE PROGRAM (HOPE WE HAVEN'T BEEN RESET)

NXTDG:	IDIVI	A,=8		;convert number in A to octal ASCII string
	HRLM	B,(P)
	JUMPE	A,.+2
	PUSHJ	P,NXTDG
	HLRZ	A,(P)
	ADDI	A,"0"
	OUTCHR	A
	POPJ	P,

DOEXIT:	EXIT	1,
	JRST	NEXT
;GETCH

GETCH:	SOSG	IBUF+2		;any more chars in buffer?
	IN	TI,		;no--next buffer please
	JRST	GETCH1
	STATO	TI,20000	;EOF?
	UFATAL	116		;;;DSK INPUT ERROR
	SETZB	W,Z
	RENAME	TI,W		;delete the file just read
	UFATAL	120		;;;CANT DELETE .TFL FILE
	SETOM	EOF		;NOTE WE HAVE NO INPUT FILE ANY MORE
	MOVE	P,[IOWD LPDL,PDL] ;yes--reset stack pointer
	JRST	@EOFDSP		;dispatch to EOF routine

GETCH1:	CAIN	C,CR		;was previous char a CR?
	JRST	POSTCR		;yes
	CAIN	C,LF		;no--was it a LF?
	JRST	POSTLF		;yes
	ILDB	C,IBUF+1	;no--get next char
	CAIN	C,LF		;next char a LF?
	JRST	PUTCRL		;yes--insert a CR before the LF
	JRST	PUTCH		;and save it

POSTCR:	ILDB	C,IBUF+1	;previous char was a CR--get next char
	CAIN	C,LF		;do we have a LF after the CR?
	JRST	PUTCH1		;yes--go store it
	PUSH	P,C		;no
	PUSHJ	P,PUTLF		;insert a LF
	POP	P,C
	CAIN	C,CR		;do we have a CR after the CRLF?
	JRST	LFCR		;yes--insert a space before the second CR
	JRST	PUTCH		;no--store the new char

POSTLF:	ILDB	C,IBUF+1	;previous char was a LF
	CAIN	C,CR
	JRST	LFCR		;LF followed by CR--insert a space
	CAIE	C,LF
	JRST	PUTCH		;nothing special here
	MOVEI	R,[ASCIZ / 
/]				;LF followed by LF--insert a space and a CR
	JRST	PUTSTR
LFCR:	MOVEI	R,[BYTE(7)" ",CR]
	JRST	PUTSTR
;PUTCH	PUTSTR	PUT2DG

PUTCH:	JUMPN	C,PUTCH2
	MOVEI	C,010700
	HRLM	C,IBUF+1	;skip to end of current input word
	MOVE	P,[IOWD LPDL,PDL] ;restore stack pointer
	JRST	@EOSDSP		;end-of-story routine

PUTCH2:	CAIL	L,=75		;line too long?
	CAIE	C," "		;yes.  do we have a space so that we can break here?
	JRST	PUTCH1		;no
PUTCRL:	MOVEI	C,CR		;yes--replace space with a CR and a LF
	PUSHJ	P,PUTCH1
PUTLF:	MOVEI	C,LF
PUTCH1:	IDPB	C,Q
	CAIN	C,LF		;got a LF?
	TDZA	L,L		;yes--note back at left margin
	ADDI	L,1		;no--note moved one more column to right
	CAME	Q,[POINT 7,BUFEND,34] ;running out of story buffer space?
	POPJ	P,		;no--all ok
	MOVE	P,[IOWD LPDL,PDL] ;yes
	JRST	ENDIT1		;put special ending on story

PUTSTR:	TLOA	R,440700	;make a byte pointer to string
	PUSHJ	P,PUTCH		;store a char
PUTST1:	ILDB	C,R		;next char
	JUMPN	C,.-2		;null?
	LDB	C,Q		;get last character put out
	POPJ	P,		;yes--done

PUT2DG:	IDIVI	A,=10		;routine to convert number in A to 2 digits of ASCII
	ADDI	A,"0"
	IDPB	A,Q
	ADDI	B,"0"
	IDPB	B,Q
	POPJ	P,
;MAKTIM

MAKTIM:	MOVEI	D," "
	IDPB	D,Q
	IDPB	D,Q		;two spaces before the time
	OUTFIV	BUF	;TYPE OUT SEQ NUMBER
	ACCTIM	A,		;get date and time
	PUSH	P,A		;and save for printing date later
	ANDI	A,-1		;clear date
	IDIVI	A,=60		;convert time to minutes
	IDIVI	A,=60		;convert to hours
	PUSH	P,B		;save minutes
	PUSHJ	P,PUT2DG	;print hours
	POP	P,A
	PUSHJ	P,PUT2DG	;print minutes
	IDPB	D,Q
	IDPB	D,Q		;two spaces after time and before date
	HLRZ	A,(P)		;retrieve date
	IDIVI	A,=31
	MOVEM	A,(P)		;save months
	MOVEI	A,1(B)
	PUSHJ	P,PUT2DG	;print day of month
	IDPB	D,Q		; and one space
	POP	P,A
	IDIVI	A,=12
	MOVEI	R,MONTH(B)
	PUSHJ	P,PUTSTR	;print month and a space
	ADDI	A,=64
	PUSHJ	P,PUT2DG	;print year
	MOVEI	D,CR		;put CRLF after date
	IDPB	D,Q
	MOVEI	D,LF
	IDPB	D,Q
	POPJ	P,
;TFLFIL	BADTFL

TFLFI1:	UWARN	122		;;;LOOKUP FAILED ON .TFL FILE
TFLFIL:	AOSLE	X,TFL		;any more .TFL files in sorted list?
	JRST	CHKUFD		;no--see if any listed in UFD
	MOVE	W,TFLST-1(X)	;yes--get name of next one
	MOVSI	X,'TFL'
	SETZ	Z,
	LOOKUP	TI,W
	JRST	TFLFI1

	HLRZ	X,W		;DATE INTO X
	MOVEI	Y,(W)		;TIME INTO Y
	CAIL	Y,APMIDNIGHT	;AFTER MIDNIGHT AP TIME?
	ADDI	X,1		;YES--NEXT DAY
	CAMGE	X,MINDATE	;REASONABLE DATE?
	JRST	BADTFL		;NO
	MOVEM	X,MINDATE	;YES

	ACCTIM	Z,		;GET CURRENT DATE/TIME
	HLRZ	Y,Z		;DATE INTO Y
	DAYCNT	Y,		;CONVERT TO DAYCNT FORMAT
	CAIL	Y,ABSMINDATE	;REASONABLE DATE?
	CAILE	Y,ABSMAXDATE
	UFATAL	124		;;;SYSTEM DATE SCREWED UP
	ANDI	Z,-1		;TIME ONLY IN Z
	CAIL	Z,APMIDNIGHT	;IS IT AFTER MIDNIGHT AP TIME?
	ADDI	Y,1		;YES--PRETEND NEXT DAY HERE
	CAIG	X,(Y)		;IS FILE'S DATE LATER THAN TODAY?
	CAMGE	Y,TODAY		;HAS TODAY GONE BACKWARDS?
	UFATAL	126		;;;SYSTEM DATE IS SCREWED UP
	MOVEM	Y,TODAY
	SETZM	EOF		;NOTE THAT WE HAVE AN AVAILABLE INPUT FILE

CPOPJ1:	AOS	(P)
CPOPJ:	POPJ	P,

BADTFL:	UWARN	130		;;;BAD FILENAME IN .TFL FILE
	MOVSI	X,'BFL'
	SETZM	Y,Z
	RENAME	TI,W		;RENAME .BFL←.TFL
	UFATAL	132		;;;CANT RENAME BAD .TFL FILE TO .BFL
	JRST	TFLFIL
;CHKUFD	UFDENT	OPNUFD

OPNUFD:	INIT	UFD,210
	SIXBIT	/DSK/
	UBUF
	UFATAL	134		;;;CANT INIT DSK
	MOVEI	W,UFDBUF
	MOVEM	W,JOBFF↑
	INBUF	UFD,NUBUFS	;SET UP BUFFERS FOR UFD IN SPECIAL BLOCK

	MOVE	W,[APPPN]
	MOVSI	X,'UFD'
	MOVE	Z,['  1  1']
	LOOKUP	UFD,W
	UFATAL	136		;;;CANT LOOK UFD
	POPJ	P,

CHKUFD:	PUSHJ	P,OPNUFD
	MOVEI	Z,'TFL'		;LOOK FOR FILES WITH EXTENSION .TFL
	PUSHJ	P,UFDENT
	JUMPE	W,CPOPJ
	MOVEM	W,TFLST-1
	SETOB	Y,TFL		;we have one file in sorted list so far
CHKUF1:	PUSHJ	P,UFDENT
	JUMPE	W,TFLFIL
	CAMLE	W,TFLST(Y)	;move up sorted list til find place to insert
	AOJL	Y,.-1
	MOVEI	X,TFLST-1
	ADD	X,TFL		;address to BLT to to make room for inserted file
	HRLI	X,1(X)		;BLT each entry down one word
	BLT	X,TFLST-2(Y)	;move list (Y points to first one not moved)
	MOVEM	W,TFLST-1(Y)	;insert new entry
	SOS	Y,TFL		;note list is now one entry longer
	CAMLE	Y,[-LTFLST]	;is list too long?
	JRST	CHKUF1		;no
	halt			;yes--we need to BLT whole list upwards
	MOVEI	Y,LTFLST-1
	MOVE	W,TFLST-LTFLST-1(Y)
	MOVEM	W,TFLST-LTFLST(Y)
	SOJG	Y,.-2
	MOVNI	Y,LTFLST-1
	MOVEM	Y,TFL
	JRST	CHKUF1

;ROUTINE TO FIND NEXT UFD ENTRY WITH EXTENSION SPECIFIED IN RIGHT HALF OF AC Z
;RETURNS NEXT FILE NAME IN W, OR ZERO IF NO MORE FILES WITH GIVEN EXTENSION
UFDENT:	SOSLE	UBUF+2
	JRST	UFDEN2
	IN	UFD,
	JRST	UFDEN1
	STATO	UFD,20000	;EOF?
	UFATAL	140		;;;INPUT DSK ERROR FROM READING UFD
	RELEAS	UFD,
	SETZ	W,		;yes--note no more UFD entries
	POPJ	P,
UFDEN1:	MOVE	W,UBUF+2
	ASH	W,-2		;divide UFD buffer word count by 4
	MOVEM	W,UBUF+2
UFDEN2:	ILDB	W,UBUF+1	;PICK UP FILE NAME
	ILDB	X,UBUF+1	;AND EXTENSION
	AOS	UBUF+1		;SKIP THIRD AND FOURTH WORDS OF EACH UFD ENTRY
	AOS	UBUF+1
	JUMPE	W,UFDENT	;ZERO FILE NAME MEANS ENTRY NOT IN USE
	HLRZ	X,X		;PUT EXTENSION IN RIGHT HALF
	CAIE	X,(Z)		;GOT EXTENSION WE ARE LOOKING FOR?
	JRST	UFDENT		;NO
	POPJ	P,		;YES
;READAT	WRTDAT	WAIT

READAT:

IFN DEBUG, <
	HRLZ	W,JOBSYM↑	;GET PTR TO SYMBOL TABLE
	CAMN	W,[SYM,,0]	;HAVE WE MOVED SYMBOLS ALREADY?
	JRST	NOMOVE		;YES
	HRRI	W,SYM		;ADDRESS OF NEW LOC FOR SYMBOL TABLE
	HRRM	W,JOBSYM	;MAKE NEW PTR TO SYMBOL TABLE
	HLRE	X,JOBSYM	;GET LENGTH OF SYMBOL TABLE
	MOVN	X,X		;AND MAKE IT POSITIVE
	CAILE	X,LSYM
	UFATAL	142		;;;NOT ENOUGH ROOM FOR MOVED SYMBOL TABLE
	ADDI	X,-1(W)		;CALCULATE ADDRESS OF LAST WORD
	BLT	W,(X)		;MOVE IT
NOMOVE:
>

	MOVE	W,TODAY
	CAMN	W,DATIN		;HAS .DAT ALREADY BEEN READ IN?
	JRST	READA4
	MOVEM	W,DATIN		;NO, BUT ITS WILL HAVE BEEN IN A SEC
	OPEN	DAT,DSK17
	UFATAL	144		;;;CANT OPEN DSK
	MOVSI	X,'DAT'
	SETZ	Z,
	LOOKUP	DAT,W
	JRST	READA1
READA2:
	HLLM	Z,DATCMD	;set up word count for reading .DAT
	HRRZ	Y,DATCMD	;get address where .DAT file will go
	MOVS	Z,Z		;negative length of .DAT file into Z
	SUB	Y,Z		;address of last word in .DAT file
	ADDI	Y,2000*4	;MAKE SURE WE HAVE ROOM TO SPARE
	CAMG	Y,JOBREL↑	;already have enough core?
	JRST	READA3		;yes
	CORE	Y,		;get enough
	UFATAL	146		;;;CANT GET ENOUGH CORE
READA3:	IN	DAT,DATCMD
	POPJ	P,
	UFATAL	150		;;;DSK INPUT ERROR READING .DAT FILE

READA4:	HLRZ	Y,DATA+2	;PICK UP POINTER TO FIRST FREE WORD IN DAT
	ADDI	Y,DATA+2000*4	;ADD 4K OF SPARE ROOM
	CAMG	Y,JOBREL↑	;ALREADY GOT ENOUGH ROOM?
	POPJ	P,		;YES, RELAX
	CORE	Y,		;NO, GET ENOUGH
	UFATAL	152		;;;CANT GET ENOUGH CORE
	POPJ	P,

READA1:	ANDI	X,-1
	JUMPE	X,.+2		;.DAT FILE NON-EXISTENT?
	UFATAL	154		;;;LOOKUP ERROR FOR .DAT FILE
	MOVEI	X,CHKBK
	SWAP	X,		;RUN CHK ON ANOTHER JOB
	OPEN	TO,DSK17
	UFATAL	156		;;;CANT INIT DSK
	MOVSI	X,'TXT'
	MOVSI	Y,077000
	SETZ	Z,
	ENTER	TO,W		;CREATE .TXT FILE
	UFATAL	160		;;;CANT ENTER NEW .TXT FILE
	RELEAS	TO,		;WITH NOTHING IN IT
	MOVSI	W,'INI'
	MOVSI	X,'DAT'
	SETZ	Z,
	LOOKUP	DAT,W		;GET INITIAL COPY OF .DAT FILE FROM 'INI.DAT'
	UFATAL	162		;;;CANT LOOKUP INI.DAT FILE
	JRST	READA2

WRTDAT:	CLOSE	DAT,
	MOVE	W,TODAY
	MOVSI	X,'DAT'
	MOVSI	Y,077000
	SETZ	Z,
	ENTER	DAT,W
	UFATAL	164		;;;CANT ENTER .DAT FILE
	HLRZ	W,DATA+2	;GET POINTER TO FIRST FREE WORD IN DAT
	SETZM	DATA(W)		;ZERO THE FIRST FREE WORD
	MOVNI	W,1(W)		;get negative (word count + 1) of .DAT file to write
	HRLM	W,DATCMD	;and store in dump mode command
	OUT	DAT,DATCMD
	JRST	.+2
	UFATAL	166		;;;DISK OUTPUT ERROR WRITING .DAT FILE
	CLOSE	DAT,
	POPJ	P,

WAIT:	EXCH	A,(P)		;get return address
	SUBI	A,2		;and make into real return address
	MOVEM	A,HNGADR	;and store
	AOS	A,HNGTIM	;count another time hung
	CAIN	A,=20
	UWARN	170		;;;COULD NOT OPEN .TXT FILE FOR 3 1/2 minutes
	CAIN	A,=40
	UWARN	172		;;;COULD NOT OPEN .TXT FILE FOR 13 2/3 minutes
	CAIL	A,=60
	UFATAL	174		;;;COULD NOT OPEN .TXT FILE FOR 30 1/2 minutes
	SLEEP	A,		;sleep a little longer each time
	POP	P,A
	JRST	@HNGADR
;NETWRK

NETWRK:	OPEN	DT,DSK417	; .DAT FILE
	UFATAL	200		;;;CANT OPEN DSK
	OPEN	TX,DSK417	; .TXT FILE
	UFATAL	202		;;;CANT OPEN DSK
	OPEN	D0,DSK17	; DATE00.DAT FILE
	UFATAL	204		;;;CANT OPEN DSK
	MOVE	Q,['DATE00']
	MOVSI	R,'DAT'
	SETZ	X,		;USE ZERO PPN
	LOOKUP	D0,Q
	UFATAL	206		;;;CANT LOOKUP DATE00.DAT
	IN	D0,DATECM
	SKIPA	Q,DATE00	;GET SFSTDA--FIRST DAY OF NEWS AROUND
	UFATAL	210		;;;DISK INPUT ERROR
	CLOSE	D0,
	CAIGE	Q,7420		;REASONABLE DATE? (ON OR AFTER 13-MAY-74?)
	UFATAL	212		;;;DATE TOO SMALL IN DATE00.DAT
	DAYCNT	Q,
	MOVE	X,TODAY		;TODAY'S DAYCNT DATE
	CAIL	Q,-=14(X)	;DO WE HAVE NEWS MORE THAN 14 DAYS OLD?
	JRST	NETWR9		;NO, DON'T DO ANYTHING
	SETZ	X,		;YES, DELETE A DAY'S NEWS IF DUMPED TWICE
	LOOKUP	DT,Q		;LOOKUP .DAT FILE
	UFATAL	214		;;;LOOKUP FAILED ON .DAT FILE
	CAMGE	Z,[100000,,0]	;FILE DUMPED TWO OR MORE TIMES?
	JRST	NETWR9		;NO, LET IT LIVE
	MOVSI	R,'TXT'
	SETZ	X,		;ZERO PPN
	LOOKUP	TX,Q		;LOOKUP .TXT FILE
	UFATAL	216		;;;LOOKUP FAILED FOR .TXT FILE
	CAMGE	Z,[100000,,0]	;FILE DUMPED TWO OR MORE TIMES?
	JRST	NETWR9		;NO, LET IT LIVE

	ADDI	Q,1		;ADVANCE FIRST NEWS DATE (DAYCNT FORMAT)
	MOVEI	C,3		;DISTANCE BETWEEN 29-FEB AND 1-MAR
	AOS	A,DATE00	;ADVANCE FIRST NEWS DATE (SYSTEM FORMAT)
	AOS	B,A		;KEEP ADVANCING SYS DATE
	DAYCNT	B,		; IN CASE AT END OF MONTH
	CAIE	B,Q		;GOT RIGHT DAYCNT DATE?
	SOJG	C,.-3		;NO
	JUMPLE	C,.+2		;JUMP IF NOT AT END OF MONTH
	MOVEM	A,DATE00	;STORE REAL NEW FIRST NEWS' DATE
	MOVE	W,['DATE00']
	MOVSI	X,'DAT'
	SETZB	Y,Z		;CLEAR PROTECTION, PPN
	ENTER	D0,W		;MAKE NEW DATE00.DAT FILE
	UFATAL	220		;;;CANT ENTER DATE00.DAT FILE
	OUT	D0,DATECM
	JRST	.+2
	UFATAL	222		;;;DISK OUTPUT ERROR
	CLOSE	D0,

	SETZB	Q,X		;ZERO FILENAME, PPN
	RENAME	DT,Q		;DELETE .DAT FILE
	UFATAL	224		;;;CANT DELETE .DAT FILE
	RENAME	TX,Q		;DELETE .TXT FILE
	UFATAL	226		;;;CANT DELETE .TXT FILE
NETWR9:	RELEAS	DT,
	RELEAS	TX,
	RELEAS	D0,
	POPJ	P,
;DATA

	VAR
	LIT
DATA:	0			;.DAT FILE WILL GO HERE

	END	DOER